home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / PASCAL / ALLSWAGS.ZIP / SWAGG-M.ZIP / MISC.SWG / 0158_approx phase of the moon.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-09-04  |  2.1 KB  |  56 lines
  1. program moondays;
  2.  
  3. uses dos;
  4.  
  5. {----------------------------------------------------------------------}
  6. {--           Calculate Approxmiate Phase of the Moon:               --}
  7. {----------------------------------------------------------------------}
  8. {-- Uses formula by P. Harvey in the "Journal of the British         --}
  9. {-- Astronomical Association", July 1941. Formula is accurate to     --}
  10. {-- within one day (or on some occassions two days). If anyone knows --}
  11. {-- a better formula please let me know! Internet: as544@torfree.net --}
  12. {----------------------------------------------------------------------}
  13. {-- Calculates number of days since the new moon where:              --}
  14. {--    0 = New moon       15 = Full Moon                             --}
  15. {--    7 = First Quarter  22 = Last Quarter (right half dark)        --}
  16. {----------------------------------------------------------------------}
  17. Function Moon_age(y : word; m : word; d : word) : byte;
  18. var i : integer;
  19.     c : word;
  20. begin
  21.      c:=(y div 100);
  22.      if (m>2) then dec(m,2) else inc(m,10);
  23.      i:=((((((y mod 19)*11)+(c div 3)+(c div 4)+8)-c)+m+d) mod 30);
  24.      moon_age:=i;
  25. end;
  26.  
  27. {----------------------------------------------------------------------}
  28. {-- Enable Dos redirection:                                          --}
  29. {----------------------------------------------------------------------}
  30. Procedure DosRedirect;
  31. begin
  32.      ASSIGN(Input,'');RESET(Input);
  33.      ASSIGN(Output,'');REWRITE(Output);
  34. end;
  35.  
  36. {**********************************************************************}
  37. {**********************************************************************}
  38. var
  39.    ty, tm, td, tdow : word;
  40. BEGIN
  41.      DosRedirect;
  42.      Getdate(ty,tm,td,tdow);
  43.      tdow := Moon_age(ty,tm,td);
  44.      Write('The moon is ',tdow,' day');
  45.      if tdow<>1 then write('s');
  46.      write(' old.');
  47.      case tdow of
  48.           0 : Write('  New moon!');
  49.           7 : Write('  First Quater!');
  50.           15: Write('  Full moon!');
  51.           22: Write('  Last Quarter!');
  52.      end;
  53.      writeln;
  54. END.
  55.  
  56.